Collection of Tools & Utilities/Collection of Tools and Utilities.iso/pascal/xlibpas2.zip/XGIF2.PAS

Pascal/Delphi Source File | 1994-06-12 | 17.4 KB | 756 lines

unit XGIF2;
{ ************************************************
  **    GIF Decoding and Encoding procedures    **
  **        for Borland/Turbo Pascal 7.0        **
  **                                            **
  **     Written by Tristan Tarrant, 1994       **
  **                                            **
  **        ( Supports GIF87a/GIF89a )          **
  ************************************************ }

interface

uses
    Dos;

const
    { Error constants used in GIF decoder }
    GoodRead      = 0;
    BadFile       = 1;
    BadRead       = 2;
    UnexpectedEOF = 3;
    BadCode       = 4;
    BadFirstCode  = 5;
    NoFile        = 6;
    BadSymbolSize = 7;
    NoCode        = -1;
    Gif87a        = 0;
    Gif89a        = 1;

    { These values will be masked with the codes output from the
        decoder to remove spurious bits }
    CodeMask : array[1..13] of word =
        ( $0000,
            $0001, $0003,
            $0007, $000F,
            $001F, $003F,
            $007F, $00FF,
            $01FF, $03FF,
            $07FF, $0FFF );

Type
    GifLineProcType = procedure( Var pixels; line, width : integer );
    GifPixelProcType = function : integer;
    TByteArray = Array[0..0] of byte;
    TIntArray = Array[0..0] of integer;

Var
    { Pointers to custom procedures to deal with lines. GifOutLineProc
      is called with three parameters : an untyped var, containing
      the uncompressed data, and two integer values, containing the
      line number and the width of the line.
      GifInPixelProc should instead return a pixels value, -1 if at the
      end of the data. }

    GifOutLineProc : GifLineProcType;
    GifInPixelProc : GifPixelProcType;
    GifPalette : array[0..767] of byte;



function LoadGif( f : string ) : integer;
function SaveGif( f : string; width, depth, bits : integer; var palette ) : integer;
function GifError( ErrorCode : integer ) : string;

Implementation

type
    GifHeader =
        record
            sig : array[1..6] of char;
            screenwidth, screendepth : word;
            flags, background, aspect : byte;
        end;

    ImageBlock =
        record
            left, top, width, depth : word;
            flags : byte;
        end;

    FileInfo =
        record
            width, depth, bits,
            flags, background : integer;
            palette : array[1..768] of byte;
        end;

    ControlBlock =
        record
            blocksize, flags : byte;
            delay : word;
            transparentcolour, terminator : byte;
        end;

    PlainText =
        record
            blocksize : byte;
            left, top, gridwidth, gridheight : word;
            cellwidth, cellheight, forecolour, backcolour : byte;
        end;

    Application =
        record
            blocksize : byte;
            applstring : array[1..8] of char;
            authentication : array[1..3] of char;
        end;


const
    TableSize = 5003;
    LargestCode = 4095;

function UnpackImage( var F : File; bits : integer; Var fi : FileInfo ) : integer;
var
    bits2, codesize, codesize2, nextcode, thiscode,
    oldtoken, currentcode, oldcode, bitsleft, blocksize,
    line, pass, byt, p, q, u : integer;
    b : array[0..255] of byte;
    linebuffer, firstcodestack, lastcodestack : ^TByteArray;
    codestack : ^TIntArray;
const
    wordmasktable : array[0..15] of word =
        ( $0000, $0001, $0003, $0007, $000F, $001F,
            $003F, $007F, $00FF, $01FF, $03FF, $07FF,
            $0FFF, $1FFF, $3FFF, $7FFF );
    inctable : array[0..4] of integer = ( 8, 8, 4, 2, 0 );
    starttable : array[0..4] of integer = ( 0, 4, 2, 1, 0 );
begin
    pass := 0;
    line := 0;
    byt := 0;
    p := 0;
    q := 0;
    blocksize := 0;
    fillchar( b, 256, 0 );
    bitsleft := 8;
    if ( bits < 2 ) or ( bits > 8 ) then
    begin
        UnpackImage := BadSymbolSize;
        exit;
    end;
    bits2 := 1 shl bits;
    nextcode := bits2 + 2;
    codesize := bits + 1;
    codesize2 := 1 shl codesize;
    oldcode := NoCode;
    oldtoken := NoCode;
    getmem( firstcodestack, 4096 );
    getmem( lastcodestack, 4096 );
    getmem( codestack, 8192 );
    getmem( linebuffer, fi.width );
    while true do
    begin
        if bitsleft = 8 then
        begin
            inc(p);
            if p>=q then
            begin
                blocksize := 0;
                blockread( F, blocksize, 1);
                if blocksize>0 then
                begin
                    p:=0;
                    blockread( F, b, blocksize, q );
                    if q<>blocksize then
                    begin
                        freemem( firstcodestack, 4096 );
                        freemem( lastcodestack, 4096 );
                        freemem( codestack, 8192 );
                        freemem( linebuffer, fi.width );
                        UnpackImage := UnexpectedEOF;
                        exit;
                    end;
                end else
                begin
                    freemem( firstcodestack, 4096 );
                    freemem( lastcodestack, 4096 );
                    freemem( codestack, 8192 );
                    freemem( linebuffer, fi.width );
                    UnpackImage := UnexpectedEOF;
                    exit;
                end;
            end;
            bitsleft := 0;
        end;
        thiscode := b[p];
        currentcode := codesize + bitsleft;
        if currentcode <=8 then
        begin
            b[p] := b[p] shr codesize;
            bitsleft := currentcode;
        end else
        begin
            inc(p);
            if p>=q then
            begin
                blocksize := 0;
                blockread( F, blocksize, 1);
                if blocksize>0 then
                begin
                    p:=0;
                    blockread( F, b, blocksize, q );
                    if q<>blocksize then
                    begin
                        freemem( firstcodestack, 4096 );
                        freemem( lastcodestack, 4096 );
                        freemem( codestack, 8192 );
                        freemem( linebuffer, fi.width );
                        UnpackImage := UnexpectedEOF;
                        exit;
                    end;
                end else
                begin
                    freemem( firstcodestack, 4096 );
                    freemem( lastcodestack, 4096 );
                    freemem( codestack, 8192 );
                    freemem( linebuffer, fi.width );
                    UnpackImage := UnexpectedEOF;
                    exit;
                end;
            end;
            thiscode := thiscode or ( b[p] shl (8-bitsleft) );
            if currentcode <= 16 then
            begin
                bitsleft := currentcode - 8;
                b[p] := b[p] shr bitsleft;
            end else
            begin
                inc(p);
                if p>=q then
                begin
                    blocksize := 0;
                    blockread( F, blocksize, 1);
                    if blocksize>0 then
                    begin
                        p:=0;
                        blockread( F, b, blocksize, q );
                        if q<>blocksize then
                        begin
                            freemem( firstcodestack, 4096 );
                            freemem( lastcodestack, 4096 );
                            freemem( codestack, 8192 );
                            freemem( linebuffer, fi.width );
                            UnpackImage := UnexpectedEOF;
                            exit;
                        end;
                    end else
                    begin
                        freemem( firstcodestack, 4096 );
                        freemem( lastcodestack, 4096 );
                        freemem( codestack, 8192 );
                        freemem( linebuffer, fi.width );
                        UnpackImage := UnexpectedEOF;
                        exit;
                    end;
                end;
                thiscode := thiscode or ( b[p] shl (16-bitsleft) );
                bitsleft := currentcode - 16;
                b[p] := b[p] shr bitsleft;
            end;
        end;
        thiscode := thiscode and wordmasktable[codesize];
        currentcode := thiscode;
        if thiscode = bits2+1 then break;
        if thiscode > nextcode then
        begin
            freemem( firstcodestack, 4096 );
            freemem( lastcodestack, 4096 );
            freemem( codestack, 8192 );
            freemem( linebuffer, fi.width );
            UnpackImage := BadCode;
            exit;
        end;
        if thiscode = bits2 then
        begin
            nextcode := bits2+2;
            codesize := bits + 1;
            codesize2 := 1 shl codesize;
            oldtoken := NoCode;
            OldCode := NoCode;
            continue;
        end;
        u := 0;
        if thiscode = nextcode then
        begin
            if oldcode = NoCode then
            begin
                freemem( firstcodestack, 4096 );
                freemem( lastcodestack, 4096 );
                freemem( codestack, 8192 );
                freemem( linebuffer, fi.width );
                UnpackImage := BadFirstCode;
                exit;
            end;
            firstcodestack^[u] := oldtoken;
            inc( u );
            thiscode := oldcode;
        end;
        while thiscode >= bits2 do
        begin
            firstcodestack^[u] := lastcodestack^[thiscode];
            inc( u );
            thiscode := codestack^[thiscode];
        end;
        oldtoken := thiscode;
        while true do
        begin
            linebuffer^[byt] := thiscode;
            inc( byt );
            if byt >= fi.width then
            begin
                GifOutLineProc( linebuffer^, line, fi.width );
                byt := 0;
                if fi.flags and $40 = $40 then
                begin
                    line := line + inctable[pass];
                    if line >= fi.depth then
                    begin
                        inc(pass);
                        line := starttable[pass];
                    end;
                end else inc(line);
            end;
            if u <= 0 then break;
            dec( u );
            thiscode := firstcodestack^[u];
        end;
        if (nextcode < 4096) and (oldcode <> NoCode) then
        begin
            codestack^[nextcode] := oldcode;
            lastcodestack^[nextcode] := oldtoken;
            inc( nextcode );
            if (nextcode >= codesize2) and (codesize < 12) then
            begin
                inc( codesize );
                codesize2 := 1 shl codesize;
            end;
        end;
        oldcode := currentcode;
    end;
    freemem( firstcodestack, 4096 );
    freemem( lastcodestack, 4096 );
    freemem( codestack, 8192 );
    freemem( linebuffer, fi.width );
    UnpackImage := GoodRead;
end; { UnpackImage }

procedure SkipExtension( Var F : File );
var
    pt : PlainText;
    cb : ControlBlock;
    ap : Application;
    i : integer;
    a, n, c : byte;
    r : word;
begin
    blockread( F, c, 1 );
    case c of
        $01 :
            begin
                blockread( F, pt, sizeof( PlainText ) );
                blockread( F, n, 1 );
                while n > 0 do
                begin
                    for i := 0 to n-1 do
                        blockread( F, a, 1 );
                    blockread( F, n, 1 );
                end;
            end;
        $F9 :
            blockread( F, cb, sizeof( ControlBlock ) );
        $FE :
            begin
                blockread( F, n, 1 );
                while n > 0 do
                begin
                    for i:= 0 to n-1 do
                        blockread( F, a, 1 );
                    blockread( F, n, 1 );
                end;
            end;
        $FF :
            begin
                blockread( F, ap, sizeof( Application ) );
                blockread( F, n, 1 );
                while n > 0 do
                begin
                    for i := 0 to n-1 do
                        blockread( F, a, 1 );
                    blockread( F, n, 1 );
                end;
            end;
        else
            begin
                blockread( F, n, 1 );
                for i := 0 to n-1 do
                        blockread( F, a, 1 );
            end;
    end;
end; { SkipExtension }

function UnpackGIF( Var F : File ) : integer;
var
    gh : GifHeader;
    iblk : ImageBlock;
    t : longint;
    b, c : integer;
    r : word;
    ch : char;
    fi : FileInfo;
begin
    blockread( F, gh, SizeOf(GifHeader), r );
    if ( gh.sig[1]+gh.sig[2]+gh.sig[3]<>'GIF' ) or ( r<>SizeOf(GifHeader) ) then
    begin
        UnpackGIF := BadFile;
        exit;
    end;
    fi.width := gh.screenwidth;
    fi.depth := gh.screendepth;
    fi.bits := gh.flags and $07 + 1;
    fi.background := gh.background;
    if ( gh.flags and $80 )=$80 then
    begin
        c:=3*( 1 shl fi.bits );
        blockread( F, fi.palette, c, r );
        if r<>c then
        begin
            UnpackGIF := BadRead;
            exit;
        end;
        for b := 0 to 255 do
        begin
            GIFPalette[b*3] := fi.palette[b*3+1] shr 2;
            GIFPalette[b*3+1] := fi.palette[b*3+2] shr 2;
            GIFPalette[b*3+2] := fi.palette[b*3+3] shr 2;
        end;

    end;
    blockread( F, ch, 1 );
    while ( ch = ',' ) or ( ch = '!' ) or ( ch = #0 ) do
    begin
        case ch of
            ',' : begin
                            blockread( F, iblk, SizeOf(ImageBlock), r );
                            if r<>SizeOf(ImageBlock) then
                            begin
                                UnpackGIF := BadRead;
                                Exit;
                            end;
                            fi.width := iblk.width;
                            fi.depth := iblk.depth;
                            if ( iblk.flags and $80 )=$80 then
                            begin
                                b := 3*(1 shl (iblk.flags and $07 + 1));
                                blockread( F, fi.palette, b, r );
                                if r<>b then
                                begin
                                    UnpackGIF := BadRead;
                                    Exit;
                                end;
                                for b := 0 to 255 do
                                begin
                                    GIFPalette[b*3] := fi.palette[b*3+1] shr 2;
                                    GIFPalette[b*3+1] := fi.palette[b*3+2] shr 2;
                                    GIFPalette[b*3+1] := fi.palette[b*3+3] shr 2;
                                end;
                            end;
                            if EOF( F ) then
                            begin
                                UnpackGIF := BadFile;
                                Exit;
                            end;
                            c:=0;
                            blockread( F, c, 1 );
                            fi.flags:=iblk.flags;
                            t := UnpackImage( F, c, fi );
                            UnpackGif:=t;
                            exit;
                        end;
            '!' : SkipExtension( F );
        end;
    end;
end; { UnpackGIF }

function LoadGif;
var
    D: DirStr;
    N: NameStr;
    E: ExtStr;
    FileHandle : File;
begin
    FSplit( F, D, N, E );
    if E='' then E:='.GIF';
    F := D+N+E;
    {$I-}
        assign( FileHandle, F );
        reset( FileHandle, 1 );
    {$I+}
    if ioresult = 0 then
        LoadGif := UnpackGif( FileHandle )
    else
        LoadGif := NoFile;
    {$I-}
        close( FileHandle );
    {$I+}
end; { LoadGif }

function WriteScreenDesc( var fp : file; width, depth, bits, background : integer; var palette ) : integer;
var
    gh : GIFHeader;
    i : integer;
    gifsig : string;
    pal : TByteArray absolute palette;
    a : byte;
begin
    FillChar( gh, sizeof(GIFHeader),0 );
    gifsig := 'GIF87a';
    move( gifsig[1], gh.sig[1], 6 );
    gh.screenwidth := width;
    gh.screendepth := depth;
    gh.background := background;
    gh.aspect := 0;
    gh.flags := $80 or ((bits-1) shl 4) or ((bits-1) and $07);
    blockwrite( fp, gh, sizeof(GIFHeader) );
    for i := 0 to (1 shl bits)*3-1 do
    begin
        a := pal[i] shl 2;
        blockwrite( fp, a, 1 );
    end;
    WriteScreenDesc := 0;
end;

function WriteImageDesc( var fp : file; left, top, width, depth, bits : integer ) : integer;
var
    ib : ImageBlock;
    ch : char;
begin
    fillchar( ib, sizeof(ImageBlock), 0 );
    ch := ',';
    blockwrite( fp, ch, 1 );
    ib.left := left;
    ib.top := top;
    ib.width := width;
    ib.depth := depth;
    ib.flags := bits-1;
    blockwrite( fp, ib, sizeof(ImageBlock) );
    WriteImageDesc := 0;
end;


function CompressImage( var fp : file; mincodesize : word ) : integer;
var
    prefixcode, suffixchar, hx, d : integer;
    codebuffer, newcode : ^TByteArray;
    oldcode, currentcode : ^TIntArray;
    codesize, clearcode, eofcode, bitoffset,
    byteoffset, bitsleft, maxcode, freecode : integer;


    procedure InitTable( mincodesize : integer );
    var
        i : integer;
    begin
        codesize := mincodesize + 1;
        clearcode := 1 shl mincodesize;
        eofcode := clearcode+1;
        freecode := clearcode+2;
        maxcode := 1 shl codesize;
        for i := 0 to tablesize-1 do
            currentcode^[i] := 0;
    end;

    procedure Deallocate;
    begin
        freemem( newcode, tablesize+1 );
        freemem( currentcode, (tablesize+1)*2 );
        freemem( oldcode, (tablesize+1)*2 );
        freemem( codebuffer, 260 );
    end;

    procedure FlushFile( var fp : file; n : integer );
    var
        a : byte;
    begin
        a := n;
        blockwrite( fp, a, 1 );
        blockwrite( fp, codebuffer^[0], n );
    end;

    procedure WriteCode( var fp : file; code : integer );
    var
        temp : longint;
    begin
        byteoffset := bitoffset shr 3;
        bitsleft := bitoffset and 7;
        if byteoffset >= 254 then
        begin
            FlushFile( fp, byteoffset );
            codebuffer^[0] := codebuffer^[byteoffset];
            bitoffset := bitsleft;
            byteoffset := 0;
        end;
        if bitsleft > 0 then
        begin
            temp := ( longint(code) shl bitsleft ) or codebuffer^[byteoffset];
            codebuffer^[byteoffset] := temp;
            codebuffer^[byteoffset+1] := temp shr 8;
            codebuffer^[byteoffset+2] := temp shr 16;
        end else
        begin
            codebuffer^[byteoffset] := code;
            codebuffer^[byteoffset+1] := code shr 8;
        end;
        bitoffset := bitoffset + codesize;
    end;


begin
    if (mincodesize<2) or (mincodesize>9) then
        if mincodesize = 1 then
            mincodesize := 2
        else
        begin
            CompressImage := 1;
            exit;
        end;
    getmem( codebuffer, 260 );
    getmem( oldcode, (tablesize+1)*2 );
    getmem( currentcode, (tablesize+1)*2 );
    getmem( newcode, tablesize+1 );
    bitoffset := 0;
    InitTable( mincodesize );
    blockwrite( fp, mincodesize, 1 );
    suffixchar := GIFInPixelProc;
    if suffixchar < 0 then
    begin
        CompressImage := 1;
        Deallocate;
        exit;
    end;
    prefixcode := suffixchar;
    suffixchar := GIFInPixelProc;
    while suffixchar<>-1 do
    begin
        hx := (prefixcode xor (suffixchar shl 5)) mod tablesize;
        d := 1;
        while true do
        begin
            if currentcode^[hx] = 0 then
            begin
                writecode( fp, prefixcode );
                d := freecode;
                if freecode <= largestcode then
                begin
                    oldcode^[hx] := prefixcode;
                    newcode^[hx] := suffixchar;
                    currentcode^[hx] := freecode;
                    inc(freecode);
                end;
                if d=maxcode then
                begin
                    if codesize<12 then
                    begin
                        inc(codesize);
                        maxcode := maxcode shl 1;
                    end else
                    begin
                        writecode( fp, clearcode );
                        InitTable( mincodesize );
                    end;
                end;
                prefixcode := suffixchar;
                break;
            end;
            if (oldcode^[hx] = prefixcode) and (newcode^[hx] = suffixchar ) then
            begin
                prefixcode := currentcode^[hx];
                break;
            end;
            hx := hx + d;
            d := d + 2;
            if hx >= tablesize then hx := hx- tablesize;
        end;
        suffixchar := GIFInPixelProc;
    end;
    writecode( fp, prefixcode );
    writecode( fp, eofcode );
    if bitoffset >0 then FlushFile( fp, (bitoffset+7) div 8 );
    FlushFile( fp, 0 );
    CompressImage := 0;
    Deallocate;
end;


function WriteGif( var fp : file; width, depth, bits : integer; var palette ) : integer;
var
    ch : char;
begin
    if WriteScreenDesc( fp, width, depth, bits, 0, palette )>0 then
        WriteGIF := 1
    else
    if WriteImageDesc( fp, 0, 0, width, depth, bits )>0 then
        WriteGIF := 2
    else
    if CompressImage( fp, bits )>0 then
        WriteGIF := 3
    else
    begin
        WriteGIF := 0;
        ch := ';';
        blockwrite( fp, ch, 1 );
    end;
end;

function SaveGif( f : string; width, depth, bits : integer; var palette ) : integer;
var
    D: DirStr;
    N: NameStr;
    E: ExtStr;
    FileHandle : File;
begin
    FSplit( F, D, N, E );
    if E='' then E:='.GIF';
    F := D+N+E;
    {$I-}
        assign( FileHandle, F );
        rewrite( FileHandle, 1 );
    {$I+}
    if ioresult = 0 then
        SaveGif := WriteGif( FileHandle, width, depth, bits, palette  )
    else
        SaveGif := NoFile;
    {$I-}
        close( FileHandle );
    {$I+}
end;

function GifError;
begin
    case ErrorCode of
        GoodRead : GifError := 'Ok';
        BadFile  : GifError := 'Bad File';
        BadRead  : GifError := 'Bad Read';
        UnexpectedEOF : GifError := 'Unexpected End';
        BadCode       : GifError := 'Bad LZW Code';
        BadFirstCode  : GifError := 'Bad First Code';
        BadSymbolSize : GifError := 'Bad Symbol Size';
        NoFile        : GifError := 'File Not Found';
        else GifError := 'Unknown';
    end;
end; { GifError }


end.